home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / itcl1_31.z / itcl1_31 / tcldev / itcl-1.3 / tests / Foo.tcl < prev    next >
Encoding:
Text File  |  1993-09-23  |  1.7 KB  |  85 lines
  1. #
  2. # Test class for [incr Tcl] test suite
  3. # ----------------------------------------------------------------------
  4. #   AUTHOR:  Michael J. McLennan       Phone: (215)770-2842
  5. #            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  6. #
  7. #     SCCS:  @(#)Foo.tcl    1.3 (9/9/93)
  8. # ----------------------------------------------------------------------
  9. #            Copyright (c) 1993  AT&T  All Rights Reserved
  10. # ======================================================================
  11.  
  12. itcl_class Foo {
  13.     #
  14.     #  Constructor/destructor add their name to a global var for
  15.     #  tracking implicit constructors/destructors
  16.     #
  17.     constructor {config} {
  18.         global WATCH
  19.         lappend WATCH [info class]
  20.         set foos($this) $this
  21.         incr nfoo
  22.     }
  23.     destructor {
  24.         global WATCH
  25.         lappend WATCH [info class]
  26.         unset foos($this)
  27.     }
  28.  
  29.     method nothing {} {}
  30.  
  31.     method do {cmds} {
  32.         return "Foo says '[eval $cmds]'"
  33.     }
  34.  
  35.     #
  36.     #  Test methods using the "config" argument
  37.     #
  38.     method config {{config -blit auto -blat matic}} {
  39.         return $config
  40.     }
  41.     method xconfig {x config} {
  42.         return "$x|$config"
  43.     }
  44.     method configx {config x} {
  45.         return "$config|$x"
  46.     }
  47.     method xecho {x args} {
  48.         return "$x | [llength $args]: $args"
  49.     }
  50.  
  51.     #
  52.     #  Test procs and access to common vars
  53.     #
  54.     proc echo {x args} {
  55.         return "$x | [llength $args]: $args"
  56.     }
  57.     proc foos {{pattern *}} {
  58.         set retn {}
  59.         foreach i [array names foos] {
  60.             if {$i != "_ignore_" && [string match $pattern $foos($i)]} {
  61.                 lappend retn $foos($i)
  62.             }
  63.         }
  64.         return $retn
  65.     }
  66.     proc nfoos {} {
  67.         return $nfoo
  68.     }
  69.  
  70.     #
  71.     #  Test public/protected/common variable definitions
  72.     #
  73.     public blit
  74.     public blat 0
  75.     public blot 1 {global WATCH; set WATCH "blot=$blot"}
  76.  
  77.     protected _blit
  78.     protected _blat 0
  79.  
  80.     common foos
  81.     set foos(_ignore_) "foos-is-now-an-array"
  82.  
  83.     common nfoo 0
  84. }
  85.